home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr01 / halcn305.zip / GSOB_STR.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-02  |  10KB  |  343 lines
  1. unit GSOB_Str;
  2. {-----------------------------------------------------------------------------
  3.                            String Handling Processor
  4.  
  5.        GSOB_STR Copyright (c)  Richard F. Griffin
  6.  
  7.        31 January 1993
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit handles string conversions.
  14.  
  15.                    SHAREWARE  -- COMMERCIAL USE RESTRICTED
  16.  
  17.    Changes:
  18.  
  19.       02 May 93 - Routines used for conversion to/from numbers have been
  20.                   modified to be of type FloatNum.  This allows numbers to
  21.                   have up to 20 significant digits.  Note that the $N+ and
  22.                   $E+ switches must be set (Alt O,C,8,E in IDE) to compile
  23.                   using this feature.  Otherwise, 11-12 digits will be used.
  24.                   The use of the $N+,E+ switch adds 10K to program size.
  25.  
  26.                   When you compile a program in the $N+,E+ state, the
  27.                   compiler links with the full 80x87 emulator.  The resulting
  28.                   .EXE file can be run on any machine, regardless of whether
  29.                   that machine has an 80x87. If an 80x87 is present, the
  30.                   program will use it; otherwise, the run-time library
  31.                   emulates it.  This gives you access to four additional
  32.                   real types: Single, Double, Extended, and Comp.  The $E+
  33.                   directive will emulate the 80x87. This gives you access
  34.                   to the IEEE floating-point types without requiring that you
  35.                   install an 80x87 chip.
  36.  
  37. ------------------------------------------------------------------------------}
  38.  
  39. interface
  40. uses
  41.    GSOB_Dte,
  42.    {$IFDEF WINDOWS}
  43.       WinDOS;
  44.    {$ELSE}
  45.       DOS;
  46.    {$ENDIF}
  47.  
  48. type
  49.    {$IFOPT N+}
  50.       FloatTyp = Extended;
  51.    {$ELSE}
  52.       FloatTyp = Real;
  53.    {$ENDIF}
  54.  
  55. function AllCaps(t : string) : string;
  56. procedure CnvAscToStr(var asc, st; lth : integer);
  57. procedure CnvStrToAsc(var st, asc; lth : integer);
  58. function PadL(strn : string; lth : integer) : string;
  59. function PadR(strn : string; lth : integer) : string;
  60. function StrCompare(var s1,s2) : integer;
  61. function StrDate(jul : longint) : string;
  62. function StrNumber(num : FloatTyp; lth,dec : integer) : string;
  63. function StrWholeNum(num : longint; lth : integer) : string;
  64. function StrLogic(tf : boolean) : string;
  65. function Strip_Flip(st : string) : string;
  66. function StripChar(ch : Char; st : string) : string;
  67. function SubStr(s : string; b,l : integer) : string;
  68. function TrimL(strn : string):string; {Deletes leading spaces}
  69. function TrimR(strn : string):string; {Deletes trailing spaces}
  70. function Unique_Field : string;       {Used to create a unique 8-byte string}
  71. function ValDate(strn : string) : longint;
  72. function ValNumber(strn : string) : FloatTyp;
  73. function ValWholeNum(strn : string) : Longint;
  74. function ValLogic(strn : string) : boolean;
  75.  
  76.  
  77. implementation
  78.  
  79.  
  80. function AllCaps(t : string) : string;
  81. var
  82.    i : integer;
  83.    l : integer;
  84.    s : string;
  85. begin
  86.    l := length(t);                 {Load string length}
  87.    move(t,s,l+1);                  {Load work string}
  88.    for i := 1 to l do s[i] := upcase(s[i]);
  89.    AllCaps := s;
  90. end;
  91.  
  92. procedure CnvAscToStr(var asc, st; lth : integer);
  93. var
  94.    a : array[0..255] of byte absolute asc;
  95.    s : string[255] absolute st;
  96.    i : integer;
  97. begin
  98.    move(a,s[1],lth);
  99.    s[0] := chr(lth);
  100.    i := pos(#0,s);
  101.    if i > 0 then dec(i)
  102.       else i := lth;
  103.    s[0] := chr(i);
  104. end;
  105.  
  106. procedure CnvStrToAsc(var st, asc; lth : integer);
  107. var
  108.    a : array[0..255] of byte absolute asc;
  109.    s : string[255] absolute st;
  110.    t : string;
  111.    i : integer;
  112. begin
  113.    t := s;
  114.    FillChar(a,lth,#0);
  115.    i := length(t);
  116.    if i >= lth then i := lth;
  117.    move(t[1],a,i);
  118. end;
  119.  
  120. function PadL(strn : string; lth : integer) : string;
  121. var
  122.    wks : string;
  123.    i   : integer;
  124. begin
  125.    i := length(strn);                    {Load string length}
  126.    move(strn,wks,i+1);                   {Load work string}
  127.    if i >= lth then
  128.    begin
  129.       if i > lth then delete(wks,1,i-lth);
  130.       PadL := wks;
  131.       exit;
  132.    end;
  133.    FillChar(wks[1],lth,' ');
  134.    move(strn[1],wks[(lth-i)+1],i);
  135.    wks[0] := chr(lth);
  136.    PadL := wks;
  137. end;
  138.  
  139. function PadR(strn : string; lth : integer) : string;
  140. var
  141.    wks : string;
  142.    i   : integer;
  143. begin
  144.    FillChar(wks[1],lth,' ');
  145.    i := length(strn);                    {Load string length}
  146.    move(strn,wks,i+1);                   {Load work string}
  147.    wks[0] := chr(lth);
  148.    PadR := wks;
  149. end;
  150.  
  151. function StrCompare(var s1,s2) : integer;
  152. var
  153.    st1 : string absolute s1;
  154.    st2 : string absolute s2;
  155.    flg : integer;
  156.    eql : boolean;
  157. begin
  158.    eql := st1 = st2;
  159.    if eql then StrCompare := 0
  160.       else if (st1 > st2) then
  161.          StrCompare := 1             {s1 > s2 if sign flag 0}
  162.             else StrCompare := -1;   {s1 < s2 if sign flag 1}
  163. end;
  164.  
  165. function StrDate(jul : longint) : string;
  166. begin
  167.    StrDate := GS_Date_View(jul);
  168. end;
  169.  
  170. function StrNumber(num : FloatTyp; lth,dec : integer) : string;
  171. var
  172.    s : string;
  173. begin
  174.    Str(num:lth:dec,s);
  175.    StrNumber := s;
  176. end;
  177.  
  178. function StrWholeNum(num : longint; lth : integer) : string;
  179. var
  180.    s : string;
  181. begin
  182.    Str(num:lth,s);
  183.    StrWholeNum := s;
  184. end;
  185.  
  186. function StrLogic(tf : boolean) : string;
  187. begin
  188.    if tf then StrLogic := 'T' else StrLogic := 'F';
  189. end;
  190.  
  191. Function Strip_Flip(st : string) : string;
  192. var
  193.    wst,
  194.    wstl : string;
  195.    i    : integer;
  196. begin
  197.    wst := TrimR(st);
  198.    wst := wst + ' ';
  199.    i := pos('~', wst);
  200.    if i <> 0 then
  201.    begin
  202.       wstl := substr(wst,1,pred(i));
  203.       system.delete(wst,1,i);
  204.       wst := wst + wstl;
  205.    end;
  206.    Strip_Flip := wst;
  207. end;
  208.  
  209. function StripChar(ch : Char; st : string) : string;
  210. var
  211.    wks : string;
  212.    i   : integer;
  213. begin
  214.    i := length(st);                      {Load string length}
  215.    move(st,wks,i+1);                     {Load work string}
  216.    while Pos(ch,wks) <> 0 do Delete(wks, Pos(ch, wks), 1);
  217.    StripChar := wks;
  218. end;
  219.  
  220. Function SubStr(s : string; b,l : integer) : string;
  221. var
  222.    st : string;
  223.    i  : integer;
  224. begin
  225.    st := '';
  226.    if b < 0 then b := 1;
  227.    st := copy(s, b, l);
  228.    SubStr := st;
  229. end;
  230.  
  231. function TrimL(strn : string) : string;
  232. var
  233.    st : string;
  234. begin
  235.    move(strn,st,length(strn)+1);      {Load work string}
  236.    st := strn;                        {Load work string}
  237.    while (length(st) > 0) and (st[1] = ' ') do delete(st, 1, 1);
  238.                                       {Loop to delete leading spaces}
  239.    TrimL := st;                       {Return trimmed string}
  240. end;
  241.  
  242. function TrimR(strn : string) : string;
  243. var
  244.    l  : integer;
  245.    st : string;
  246. begin
  247.    l := length(strn);                 {Load string length}
  248.    move(strn,st,l+1);                 {Load work string}
  249.    st[0] := '*';                      {Ensure string length is not decimal 32,}
  250.                                       {which is an ASCII space}
  251.    while st[l] = ' ' do dec(l);       {Loop searching down to first non-blank}
  252.    st[0] := chr(l);                   {Set string to new length}
  253.    TrimR := st;                       {Return trimmed length}
  254. end;
  255.  
  256. const
  257.    chrsavail : string[36]
  258.              = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  259.    LastUnique : string[8] = '        ';
  260.  
  261.  
  262. function Unique_Field : string;
  263. var
  264.    y, mo, d, dow  : Word;
  265.    h, mn, s, hund : Word;
  266.    wk, ymd, hms   : longint;
  267.    LS             : string;
  268.  
  269. {
  270.                    ┌──────────────────────────────────────┐
  271.                    │  Beginning of Unique_Field function  │
  272.                    └──────────────────────────────────────┘
  273. }
  274. begin
  275.    repeat
  276.       GetTime(h,mn,s,hund);           {Call TP 5.5 procedure for current time}
  277.       GetDate(y,mo,d,dow);            {Call TP 5.5 procedure for current date}
  278.       ymd := 10000+(mo*100)+d;
  279.       hms := ((h+10)*1000000)+(longint(mn)*10000)+(s*100)+hund;
  280.       wk := ymd mod 26;
  281.       LS := chrsavail[succ(wk) + 10];
  282.       ymd := ymd div 26;
  283.       repeat
  284.          wk := ymd mod 36;
  285.          LS := LS + chrsavail[succ(wk)];
  286.          ymd := ymd div 36;
  287.       until ymd = 0;
  288.       repeat
  289.          wk := hms mod 36;
  290.          LS := LS + chrsavail[succ(wk)];
  291.          hms := hms div 36;
  292.       until hms= 0;
  293.    until LS <> LastUnique;
  294.    LastUnique := LS;
  295.    Unique_Field := LS;                {Return the unique field}
  296.  end;
  297.  
  298. function ValDate(strn : string) : longint;
  299. var
  300.    v : longint;
  301. begin
  302.    v := GS_Date_Juln(strn);
  303.    if v > 0 then ValDate := v else ValDate := 0;
  304. end;
  305.  
  306. function ValNumber(strn : string) : FloatTyp;
  307. var
  308.    r : integer;
  309.    n : FloatTyp;
  310. begin
  311.    val(strn,n,r);
  312.    if r <> 0 then ValNumber := 0
  313.       else ValNumber := n;
  314. end;
  315.  
  316. function ValWholeNum(strn : string) : longint;
  317. var
  318.    r : integer;
  319.    n : integer;
  320. begin
  321.    val(strn,n,r);
  322.    if r <> 0 then ValWholeNum := 0
  323.       else ValWholeNum := n;
  324. end;
  325.  
  326. function ValLogic(strn : string) : boolean;
  327. var
  328.    c : char;
  329. begin
  330.    if strn[0] <> #1 then ValLogic := false
  331.    else
  332.    begin
  333.       c := strn[1];
  334.       if c in ['T','t','Y','y'] then ValLogic := true
  335.          else ValLogic := false;
  336.    end;
  337. end;
  338.  
  339.  
  340. end.
  341. {-----------------------------------------------------------------------------}
  342.                                         END
  343.